option explicit

Const vbext_ct_ClassModule = 2
Const vbext_ct_Document = 100
Const vbext_ct_MSForm = 3
Const vbext_ct_StdModule = 1

Dim xlapp, fso, wb, vbcomp, ext, folderPath, fileName, file, nbCodeLine

If Wscript.Arguments.Count <> 1 Then
	MsgBox "As the only argument, give the FULL path to an XLS file to extract all the VBA from it."
Else

	Set xlapp = CreateObject("Excel.Application")
	xlapp.Visible = true
	
	Set wb = xlapp.Workbooks.Open(Trim(wScript.Arguments(0)))		

	Set fso = CreateObject("Scripting.FileSystemObject")
	folderPath = wb.Path & "\" & fso.GetBaseName(wb.Name)

	If Not fso.FolderExists(folderPath) Then fso.CreateFolder(folderPath)

	For Each vbcomp In wb.VBProject.VBComponents
		Select Case vbcomp.Type
			Case vbext_ct_Document
				If ext = "" Then
					ext = "wbc"
				Else
					ext = "shc"
				End If
			Case vbext_ct_ClassModule
				ext = "cls"
			Case vbext_ct_MSForm
				ext = "frm"
			Case vbext_ct_StdModule
				ext = "bas"
			Case Else
				ext = "txt"
		End Select
		fileName = folderPath & "\" & vbcomp.Name & "." & ext
		Select Case ext
			Case "wbc", "shc"
				Set file = fso.CreateTextFile(fileName, True)
				nbCodeLine = vbcomp.CodeModule.CountOfLines
				If nbCodeLine > 0 Then file.WriteLine vbcomp.CodeModule.Lines(1, nbCodeLine)
				file.Close
			Case Else
				On Error Resume Next
				Err.Clear
				vbcomp.Export fileName
				If Err.Number <> 0 Then
					MsgBox "Failed to export " & fileName
				End If
				On Error GoTo 0
		End Select
	Next

	xlapp.Quit
End If